home *** CD-ROM | disk | FTP | other *** search
/ Graphics Plus / Graphics Plus.iso / libs / phigs / ptk.lha / ptk / fortran / source / demo / stcttest.f < prev    next >
Encoding:
Text File  |  1992-06-18  |  5.0 KB  |  172 lines
  1. C--------------------------------------------------------------------------- 
  2.  
  3. C Program name: StructureDraw test program.
  4.  
  5. C Author: Gareth Williams
  6.  
  7. C Description:
  8.  
  9. C Modification history : (Version), (Date), (Name), (Description).
  10.  
  11. C 1.0, 1st July 1991, G. Williams, First Version.
  12.  
  13. C 2.0, June 1992, G. Williams, Converted to SunPHIGS 2.0.
  14.  
  15. C----------------------------------------------------------------------------
  16.           
  17.        PROGRAM stcttest
  18.        INTEGER err, minid, maxid, pid
  19.        LOGICAL ptkf_readphinterscript
  20.        INTEGER ptkf_stringtoint
  21.        LOGICAL docolour
  22.  
  23.        include './sunphigs77.h'
  24.  
  25.        implicit undefined (P, p, E, e)
  26.  
  27. C colour or monochrome
  28.        docolour = .TRUE.
  29.  
  30.        print *,('Demonstrating the structure draw module of the 
  31. & PHIGS Toolkit...')
  32.        print *,('Opening SunPHIGS...')
  33.  
  34.        call popph(6, 0)
  35.  
  36. C     create the workstation type (either tool or canvas) 
  37.               
  38. C     open the workstation 
  39.  
  40.        if (ptkf_readphinterscript('../../scripts/openws.scr', 0, 0) .eq.
  41. & .FALSE.) then     
  42.          goto 30
  43.        endif
  44.  
  45.        call psdus(1, PWAITD, PNIVE)
  46.        minid = 1
  47.        maxid = 30
  48.        call ptkf_inithashtables()
  49.        call ptkf_createhashtable('structureid', minid, maxid)
  50.        call ptkf_createhashtable('label', 0, maxid)
  51.        call ptkf_createhashtable('name', 0, maxid)
  52.        call ptkf_createhashtable('colourindex', 1, 8)
  53.  
  54.        if (docolour .eq. .TRUE.) then
  55.          call ptkf_setcolourrep(1, 'black')
  56.          call ptkf_setcolourrep(1, 'white')
  57.          call ptkf_setcolourrep(1, 'grey')
  58.          call ptkf_setcolourrep(1, 'green')
  59.          call ptkf_setbackgroundcolourind(1, 
  60. & ptkf_stringtoint('colourindex', 'grey'))
  61.        endif
  62.        
  63.        if (ptkf_readphinterscript('../../scripts/postcard.scr', 
  64. & 0, 0)) then
  65.          call popst(ptkf_stringtoint('structureid', 'content'))
  66.          call set_attrs(docolour)
  67.          pid = ptkf_stringtoint('structureid', 'postcard')
  68.          call ptkf_structcontent(1, pid, 1, 0, 0, PFONTTRIPLEX, err)
  69.          call pclst()
  70.        
  71.          if (err .eq. 0) then
  72.            call ppost(1, ptkf_stringtoint('structureid', 'content'), 
  73. & 0.0)
  74.          endif
  75.  
  76.          call puwk(1, PPERFO)
  77.          call options(docolour)
  78.        endif
  79.  
  80.  30    call pclwk(1)
  81.        call pclph()
  82.  
  83.        STOP
  84.        END
  85.  
  86. C--------------------------------------------------------------------------
  87.  
  88.        SUBROUTINE options(docolour)
  89.        LOGICAL docolour
  90.        CHARACTER*20 commandstr, postcdstr, rangestr, pointstr, quitstr
  91.        INTEGER lencom, err, elem1, elem2, eptr, postcardid
  92.        LOGICAL structquit
  93.        REAL echoarea(4)
  94.        INTEGER ptkf_readint
  95.        INTEGER ptkf_stringtoint
  96.  
  97.        include './sunphigs77.h'
  98.        
  99.        postcdstr = 'postcard'
  100.        rangestr = 'range'
  101.        pointstr = 'pointer'
  102.        quitstr = 'quit'
  103.        structquit = .FALSE.
  104.        eptr = 0
  105.        postcardid = ptkf_stringtoint('structureid', 'postcard')
  106.        call ptkf_limit(0.0, 0.25, 0.0, 0.01, echoarea)
  107.  10    call ptkf_readstring(1, 'range', 
  108. & 'Input command (default = range) >', echoarea, 20, commandstr, 
  109. & lencom)
  110.        if (commandstr(1:lencom) .eq. rangestr(1:lencom)) then
  111.           elem1 = ptkf_readint(1, 1, 'Input element number (1) >', 
  112. & echoarea)
  113.           elem2 = ptkf_readint(1, 0, 'Input element number (0) >', 
  114. & echoarea)
  115.           call pemst(ptkf_stringtoint('structureid', 'content'))
  116.           call popst(ptkf_stringtoint('structureid', 'content'))
  117.           call set_attrs(docolour)
  118.           call ptkf_structcontent(1, postcardid, elem1, elem2, eptr, 
  119. & PFONTTRIPLEX, err)
  120.           call pclst()
  121.           call prst(1, PALWAY)
  122.        else if (commandstr(1:lencom) .eq. pointstr(1:lencom)) then
  123.           eptr = ptkf_readint(1, 0, 'Input element pointer (0) >', 
  124. & echoarea)
  125.           call popst(ptkf_stringtoint('structureid', 'content'))
  126.           call ptkf_setstructcontentelemptr(ptkf_stringtoint(
  127. & 'structureid', 'content'), eptr)
  128.           call pclst()
  129.           call prst(1, PALWAY)
  130.        else if (commandstr(1:lencom) .eq. quitstr(1:lencom)) then
  131.           structquit = .TRUE.
  132.        else
  133.           print *,('Command unknown')    
  134.        endif
  135.  
  136.        if (structquit .eq. .TRUE.) then
  137.          goto 20
  138.        else 
  139.          goto 10
  140.        endif
  141.  
  142.  20    RETURN
  143.        END
  144.  
  145. C--------------------------------------------------------------------------
  146.  
  147.        SUBROUTINE set_attrs(docolour)
  148.        LOGICAL docolour
  149.        INTEGER green, grey, white, black
  150.        INTEGER ptkf_stringtoint
  151.  
  152.        include './sunphigs77.h'
  153.  
  154.        if (docolour .eq. .TRUE.) then
  155.          green = ptkf_stringtoint('colourindex', 'green')
  156.          grey = ptkf_stringtoint('colourindex', 'grey')
  157.          white = ptkf_stringtoint('colourindex', 'white')
  158.          black = ptkf_stringtoint('colourindex', 'black')
  159.          call pstxci(black)
  160.          call psedfg(PON)
  161.          call psis(PSOLID)
  162.          call psedci(white)
  163.          call psici(green)
  164.        endif
  165.  
  166.        RETURN
  167.        END
  168.  
  169. C--------------------------------------------------------------------------
  170.           
  171. C     end of stcttest.f
  172.